home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_cl2.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  6.8 KB  |  260 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_cl2.c */
  5.  
  6. #include "clos.h"
  7.  
  8.  
  9.  
  10. node make_precedence_list();
  11. void make_prec_aux_u2jl2r();
  12.  
  13. void lf_mkinstance LF_PARAMS
  14. {
  15.  /* sintassi (mkinstance nomeclasse {initarg initvalue}*) */
  16.  /* si ritorna un nodo-classe che punta ad una lista */
  17.  /* lista->( (prec_list) (fields 1) ... (fields n)) */
  18.  node prec_list;
  19.  node curr_class;
  20.  node class_list;
  21.  node cl_last;
  22.  node field_list=NIL;
  23.  node fl_last;
  24.  node tmp;
  25.  node curr_initf;
  26.  node curr_inita;
  27.  
  28.  if(IS_CONS(nin)){
  29.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  30.    if(nout->type==P_VALUE || nout->type==P_UNBOUNDVALUE){
  31.      /* nout->node e' sicuramente un nome */
  32.      if(HAS_CLASS(nout->node)){
  33.  
  34.        /* CLASS(nout->node)= ( (supers) (initforms) (initargs) ) */
  35.  
  36.        prec_list=make_precedence_list(nout->node);
  37.        /* prec_list=lista di precedenze */
  38.        TYPE(cl_last=class_list=node_make())|=NT_IS_CONS;
  39.        CONSLEFT(cl_last)=prec_list;
  40.        CONSRIGHT(cl_last)=NIL;
  41.        /* class_list=( prec_list ) */
  42.        /* ora:per ogni elemento di prec_list si scorre nin per */
  43.        /* cercare eventuali initargs e si alloca una fields_list */
  44.  
  45.        for(;;){
  46.          if(CONSLEFT(prec_list)==T)break;
  47.          curr_class=CLASS(CONSLEFT(prec_list));
  48.          curr_initf=CONSLEFT(CONSRIGHT(curr_class));
  49.          curr_inita=CONSLEFT(CONSRIGHT(CONSRIGHT(curr_class)));
  50.          field_list=NIL;
  51.  
  52.          while(IS_CONS(curr_initf)){
  53.            tmp=CONSRIGHT(nin);
  54.            while(IS_CONS(tmp)){
  55.              if(!IS_CONS(CONSRIGHT(tmp)))
  56.                error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  57.  
  58.              if(CONSLEFT(tmp)==CONSLEFT(curr_inita)){
  59.                eval(CONSLEFT(CONSRIGHT(tmp)),nout,genv,lenv,EVAL_NORM);
  60.                break;
  61.              }
  62.              if(IS_VALUE(CONSLEFT(tmp))&&IS_VALUE(CONSLEFT(curr_inita))&&
  63.                 GET_VTYPE(CONSLEFT(tmp))==GET_VTYPE(CONSLEFT(curr_inita))&&
  64.                 NODE(CONSLEFT(tmp))==NODE(CONSLEFT(curr_inita)) ){
  65.                 eval(CONSLEFT(CONSRIGHT(tmp)),nout,genv,lenv,EVAL_NORM);
  66.                 break;
  67.              }
  68.              tmp=CONSRIGHT(CONSRIGHT(tmp));
  69.            }
  70.            if(!IS_CONS(tmp))
  71.              eval(CONSLEFT(curr_initf),nout,genv,lenv,EVAL_NORM);
  72.            if(field_list==NIL){
  73.              field_list=fl_last=node_make();
  74.            }else{
  75.              CONSRIGHT(fl_last)=node_make();
  76.              fl_last=CONSRIGHT(fl_last);
  77.            }
  78.            TYPE(fl_last)|=NT_IS_CONS;
  79.            CONSLEFT(fl_last)=calc_pointer(nout);
  80.            CONSRIGHT(fl_last)=NIL;
  81.  
  82.            curr_initf=CONSRIGHT(curr_initf);
  83.            curr_inita=CONSRIGHT(curr_inita);
  84.          }
  85.      CONSRIGHT(cl_last)=node_make();
  86.          cl_last=CONSRIGHT(cl_last);
  87.          TYPE(cl_last)|=NT_IS_CONS;
  88.          CONSLEFT(cl_last)=field_list;
  89.          CONSRIGHT(cl_last)=NIL;
  90.  
  91.          prec_list=CONSRIGHT(prec_list);
  92.        }
  93.        TYPE(nout->node=node_make())|=NT_IS_VALUE+NT_CLASS;
  94.        CLASS_INSTANCE(nout->node)=class_list;
  95.        nout->type=P_ALLNODE;
  96.        return;
  97.      }
  98.    }
  99.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nout->node);
  100.  }
  101.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  102. }
  103.  
  104. node make_precedence_list(classname)
  105. node classname;
  106. {
  107.  /* data classname si crea la sua lista delle precedenze */
  108.  node n=node_make();
  109.  TYPE(n)|=NT_IS_CONS;
  110.  CONSLEFT(n)=NIL;
  111.  CONSRIGHT(n)=NIL; 
  112.  make_prec_aux_u2jl2r(classname,n);
  113.  return CONSRIGHT(n);
  114. }
  115.  
  116. void make_prec_aux_u2jl2r(cname,list)
  117. node cname;
  118. node list;
  119. {
  120.  /* ALGORITMO LEFT-TO-RIGHT & UP-TO-JOIN */
  121.  /* cerca cname in list */
  122.  /* scorrendo comunque tutta la lista */
  123.  /* se trova cname nella lista lo sposta in fondo (UP-TO-JOIN) */
  124.  /* se non lo trova lo mette in fondo comunque */
  125.  /* NB:list inizia con un cons vuoto per facilitare tutte le operazioni */ 
  126.  node curr;
  127.  node prec;
  128.  node node_found;
  129.  int  found;
  130.  
  131.  curr=CONSRIGHT(list);
  132.  prec=list;
  133.  found=FALSE;
  134.  while(IS_CONS(curr)){
  135.    if(cname==CONSLEFT(curr)){
  136.      found=TRUE;
  137.      node_found=curr;
  138.      /* elimina il cons contenente cname */
  139.      CONSRIGHT(prec)=CONSRIGHT(curr);
  140.      curr=CONSRIGHT(curr);
  141.      /* chiudi il cons estratto dalla lista */
  142.      CONSRIGHT(node_found)=NIL;
  143.    }else{
  144.      prec=curr;
  145.      curr=CONSRIGHT(curr);
  146.    }
  147.  }
  148.  if(found){
  149.    /* si mette node_found in fondo alla lista list */
  150.    CONSRIGHT(prec)=node_found;
  151.  }else{
  152.    /* si alloca un nuovo cons in fondo alla lista */
  153.    /* si fa insomma (append list (cname)) */
  154.    CONSRIGHT(prec)=node_make();
  155.    TYPE(prec=CONSRIGHT(prec))|=NT_IS_CONS;
  156.    CONSLEFT(prec)=cname;
  157.    CONSRIGHT(prec)=NIL;
  158.  }
  159.  
  160.  /* si scorrono le superclassi di cname da sinistra a destra (LEFT-TO-RIGHT)*/
  161.  cname=CONSLEFT(CLASS(cname));
  162.  while(IS_CONS(cname)){
  163.    make_prec_aux_u2jl2r(CONSLEFT(cname),list);
  164.    cname=CONSRIGHT(cname);
  165.  }
  166. }
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173. void _lf_defmethod LF_PARAMS
  174. {
  175.  node func;
  176.  node fn;
  177.  
  178.  if(nin==NIL)
  179.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&NIL);
  180.  if(!IS_CONS(nin))
  181.    error(E_BADLIST,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  182.  
  183.  eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  184.  
  185.  /* nout->node e' il nome della funzione */
  186.  if(!IS_NAME(func=nout->node))
  187.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&func);
  188.  
  189.  lf_lambda(CONSRIGHT(nin),nout,genv,lenv,EVAL_NORM);
  190.  
  191.  /* si controlla se func e' gia' un metodo */
  192.  if(HAS_FUNCTION(func)&&IS_VALUE(FUNCTION(func))&&
  193.     GET_VTYPE(FUNCTION(func))==NT_METHOD){
  194.    TYPE(fn=node_make())|=NT_IS_CONS;
  195.    CONSLEFT(fn)=FUNCTION(nout->node);
  196.    CONSRIGHT(fn)=METHOD(FUNCTION(func));
  197.    METHOD(FUNCTION(func))=fn;
  198.    return;
  199.  }
  200.  /* fn non e' un metodo */
  201.  TYPE(func)|=NT_HAS_FUNCTION;
  202.  TYPE(fn=node_make())|=NT_IS_CONS;
  203.  CONSLEFT(fn)=FUNCTION(nout->node);
  204.  CONSRIGHT(fn)=NIL;
  205.  TYPE(FUNCTION(func)=node_make())|=NT_IS_VALUE+NT_METHOD;
  206.  METHOD(FUNCTION(func))=fn;
  207. }
  208.  
  209.  
  210. void lf_defmethod LF_PARAMS
  211. {
  212.  node fn,fun;
  213.  
  214.  /* sintassi (defmethod nome <lambda-form>) */
  215.  
  216.  if(IS_CONS(nin)){
  217.    if(!IS_NAME(fn=CONSLEFT(nin))){
  218.      /* se ''nome,, non e' un nome ma una s-espressione allora la valuta */
  219.      eval(fn,nout,genv,lenv,EVAL_SETF);
  220.      /* si controlla se nout e' un nome */
  221.      if(!IS_NAME(nout->node))
  222.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&fn);
  223.      fn=nout->node;
  224.    }
  225.    lf_lambda(CONSRIGHT(nin),nout,genv,lenv,EVAL_NORM);
  226.  
  227.    /* si controlla se func e' gia' un metodo */
  228.    if(HAS_FUNCTION(fn)&&IS_VALUE(FUNCTION(fn))&&
  229.           GET_VTYPE(FUNCTION(fn))==NT_METHOD){
  230.      TYPE(fun=node_make())|=NT_IS_CONS;
  231.      CONSLEFT(fun)=FUNCTION(nout->node);
  232.      CONSRIGHT(fun)=METHOD(FUNCTION(fn));
  233.      METHOD(FUNCTION(fn))=fun;
  234.      return;
  235.    }
  236.    /* fn non e' un metodo */
  237.    TYPE(fn)|=NT_HAS_FUNCTION;
  238.    TYPE(fun=node_make())|=NT_IS_CONS;
  239.    CONSLEFT(fun)=FUNCTION(nout->node);
  240.    CONSRIGHT(fun)=NIL;
  241.    TYPE(FUNCTION(fn)=node_make())|=NT_IS_VALUE+NT_METHOD;
  242.    METHOD(FUNCTION(fn))=fun;
  243.    return;
  244.  }
  245.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  246. }
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.